unit UGamesys;

interface

uses
  Sysutils, windows, {math,} classes, Graphics, {Mmsystem,} ExtCtrls,

  // other units
  Usingleton, PathFind,
  // Self-made units
  Upixeng, UMapMgr, UGraph, UResMan, Ucommon;

//------------------------------------------------------------------------------

const
  abilqnt = 3;
  spellqnt = 5;

  //------------------------------------------------------------------------------

type

{$H-} // Set strings to be shortstring (helps avoid memory bugs in copymemory in tWarrior.Add)

  {
  Tspell = reCord
    spell, spelltype, spellcost, spelltarg, spellrange,spelluse  : byte ;
    end;

  abilar = array [1..abilqnt] of byte ;
  spellar = array[1..spellqnt] of tspell ;

  }
  TprocRedraw = procedure of object;

  Nforce = (fnone, fplayer, fally, fenemy);

  TGame = class;
  TFieldCell = class;
  TArmy = class;
  TParty = class;
  TParties = class;

  //------------------------------------------------------------------------------

  TWarrior = class(TCollectionItem)
  public
    //force : Nforce;
    iscaster, isranged, ismelee, ishero, isdead, isblocked, isblockfree,
      isimmune, isflyer, isfighting: boolean;
    race, plr, inMoves, Moves, inlife, life, cost, damage, mana, shots, inshots,
      Curact, acts, inacts, spelleff, Warrnum, deadnum, spellcnt: byte;
    descr, Name: string;
    Cell: TFieldCell;
    //abils : abilar ;
    //spells : spellar ;
    //fightingWarrior : tWarrior ;
    destructor Destroy; override;
    procedure Initunit;
    procedure startturn;
    function wound(adamage, adam_type: byte): boolean;
  end;

  //------------------------------------------------------------------------------

  TWarriors = class(tCollection)
  public
    Party: TParty;
    function fGame: tGame;
    constructor Create(aParty: TParty {; aCollItemclass :tCollectionItemclass});
    destructor Destroy; override;
  end;

  TParty = class(tCollectionItem)
  public
    Speed, Time: byte;
    isTeleporting: boolean;
    force: nforce;
    Partynum, CurStep: word;
    Cell, DestCell: TFieldCell;
    Warriors: tWarriors;
    Path: TPath;
    //constructor Create(aCollection : tCollection);
    destructor Destroy; override;
    function GeTParties: TParties;
    function Moveto(aCell: TFieldCell): boolean;
    procedure doact();
    procedure Init(aCell: TFieldCell);
    procedure MovetoArmy(aArmy: TArmy);
    procedure Teleport();
    procedure Timer();
    property Parties: TParties read GeTParties;
  end;

  TArmies = class(tCollection)
  private
    fGame: tGame;
    function GetItem(Index: Integer): TArmy;
    procedure SetItem(Index: Integer; const Value: TArmy);
  public
    constructor Create(aGame: tGame {; aCollItemclass :tCollectionItemclass});
    function Add(aCell: TFieldCell): TArmy;
    destructor Destroy; override;
    property Items[Index: Integer]: TArmy read GetItem write SetItem; default;
    property theGame: TGame read fGame;
  end;

  TParties = class(tCollection)
  private
    function GetItem(Index: Integer): TParty;
    procedure SetItem(Index: Integer; const Value: TParty);
  public
    Army: TArmy;
    function fGame: tGame;
    function Add(): TParty;
    procedure delete(index: integer);
    property Items[Index: Integer]: TParty read GetItem write SetItem; default;
    constructor Create(aArmy: TArmy {; aCollItemclass : tCollectionItemclass});
    destructor Destroy; override;
  end;

  TArmy = class(tCollectionItem)
  public
    Cell: TFieldCell;
    Parties: TParties;
    isdeleting: boolean;
    function Coll: TArmies;
    procedure SendTick();
    procedure PartiesChanged;
    destructor Destroy; override;
  end;

  NObjtype = (otUnknown, otPortal);

  //------------------------------------------------------------------------------

  TGameObj = class(tObject)
    Cell: TFieldCell;
    otype, intype: NObjtype;
    subtype, insubtype: byte;
    function fGame: tGame;
    constructor Create(aCell: TFieldCell; aObjtype: nObjtype; aObjsubt: byte);
    destructor Destroy; override;
  end;

  //------------------------------------------------------------------------------
  TField = class;

  TFieldCell = class(tObject)
  private
    fField: TField;
    fArmy: TArmy;
    fObj: tGameObj;
    procedure PutObj(aObj: tGameObj);
    procedure PuTArmy(aArmy: TArmy);
    function GetNeighbour(index: integer): TFieldCell;
    function GetMirror(Index: Integer): boolean;
  public
    tertype: Ntertype;
    xCord, yCord: TCellInt;
    tertex, inagr, agr: byte;
    agRowner: TParty;
    fmirror: byte;
    onPath: Byte;
    constructor Create(ay, ax: TCellInt; aField: TField);
    destructor Destroy; override;
    function Field: TField;
    property Obj: tGameObj read fObj write PutObj;
    property Army: TArmy read fArmy write PuTArmy;
    property neighbour[index: integer]: TFieldCell read GetNeighbour;
    property mirror[index: integer]: boolean read GetMirror;
  end;

  FieldCellar = array of array of TFieldCell;
  ProcCellChanged = procedure(Sender: TObject) of object;

  TField = class(TGameIntfField)
  private
    fGame: TGame;
    FField: FieldCellar;
    FCellChanged: ProcCellChanged;
    FCurCell: TFieldCell;
    procedure SetCurCell(const Value: TFieldCell);
  protected
    procedure SetCurCoords(const Value: TPoint); override;
    function GetHeight: TCellInt; override;
    function GetWidth: TCellInt; override;
    function GetCell(ay, ax: TCellInt): TFieldCell;
    procedure ClearObj;
    procedure Clearplr(aplr: byte);
    procedure GetnearCells(yc, xc, range: byte; var sy, sx, fy, fx: shortint);
    procedure restore;
    procedure SetCell(ay, ax: TCellInt; aCell: TFieldCell);
  public
    procedure GetCellGrafic(aBmp: TBmp; ay, ax: TCellInt); override;
    constructor Create(aGame: tGame); // it does hides !
    destructor Destroy; override;
    Function Add(ay, ax: TCellInt) : TFieldCell ;
    function CheckInMap(Ay, Ax : TCellInt): Boolean;
    procedure Clearmap();
    procedure SetField(aHeight, aWidth: TCellInt);
    property Field[Row: TCellInt; Column: TCellInt]: TFieldCell read GetCell
    write SetCell; default;
    property theGame: TGame read fGame;
    property CurCell: TFieldCell read FCurCell write SetCurCell;
    property OnCellChanged: ProcCellChanged read FCellChanged write
      FCellChanged;

  end;
  //------------------------------------------------------------------------------

  TInputItem = class(TObject)
    Obj: TObject;
    Event: TNotifyEvent;
    constructor Create(Aobj : TObject; AEvent: TNotifyEvent);
  end;

  TInput = class(TObject)
  private
    FKeys: array[0..7] of array[Byte] of TMyObjList;
    function GetShiftByte(AShift: TShiftState): Byte;
    function GetShift(Val: Byte): TShiftState;
    function GetKey(Shift, Key: Byte): TMyObjList;
  public
    procedure Clear();
    destructor Destroy(); override;
    procedure KeyPress(Key: Word; Shift: TShiftState);
    procedure RegKey(Obj: TObject; Key: Word; Shift: TShiftState; Event : TNotifyEvent);
    property Keys[Shift: Byte; Key : Byte]: TMyObjList read GetKey;
  end;

  //------------------------------------------------------------------------------

  TGame = class(TSingleton)
  private
    FprocRedraw: tprocRedraw;
    fCurParty: TParty;
    fGlobTick: cardinal;
    fField: TField;
    fCurplr: byte;
    fGamePix: TGamePixels;
    FTimerEnabled: Boolean;
    FTimerEvent: TNotifyEvent;
    FInput : TInput;
    Timer : TTimer;
    procedure SetTimerEnabled(const Value: Boolean);
    procedure SetTimerEvent(const Value: TNotifyEvent);

  protected
    FTimerTick: Cardinal;
    fTimer: Integer;
    procedure SetGlobTick(const Value: cardinal);
    procedure SetprocRedraw(const Value: tprocRedraw);
    function GetprocRedraw(): tprocRedraw;
    procedure TimerInvoke(Sender: Tobject);
    constructor Create(Appdir: string); // it does hides!
  public
    //Unitar : array of TWarrior ;
    MapLoaded, MapLoading, worldChanged: boolean;
    //unitsinracecnt, racecnt, unitcnt, plrcnt, Objcnt, Objtypecnt : byte ;
    portalar: array of array of tGameObj;
    Armies: TArmies;
    //ObjNamear : array of string ;
    GridMask: TMask;
    MapMgr: TMapMgr;
    destructor Destroy; override;
    function AddField(ay, ax, ah, aw: word): TField;
    function MoveParty(aParty: TParty; aCell: TFieldCell): boolean;
    function CreateDlg(ADlg: TDlgClass; Astr: Nlngstr; AProc: TDlgcallbackproc):
      TsimpleDlg;
    procedure doTick();
    procedure GridMaskinc(aCells: array of TFieldCell);
    procedure Init(acanv: TDevice; aHeight, aWidth: word);
    procedure Loadportal(anObj: tGameObj);
    procedure MapLoad(Mapid: word);
    procedure Render({hDest: THandle});
    procedure ResetGridMask();
    procedure SetCurParty(const Value: TParty);
    procedure SetCurplr(aplr: byte);
    procedure unInit();
    property CurParty: TParty read fCurParty write SetCurParty;
    property Curplr: byte read fCurplr write SetCurplr;
    property GlobTick: cardinal read fGlobTick write SetGlobTick;
    property procRedraw: tprocRedraw read GetprocRedraw write SetprocRedraw;
    property Field: TField read fField;
    property GamePix: tGamePixels read fGamePix;
    property Timertick: Cardinal read FTimerTick;
    property TimerEnabled: Boolean read FTimerEnabled write SetTimerEnabled;
    property TimerEvent: TNotifyEvent read FTimerEvent write SetTimerEvent;
    property Input : TInput read FInput;
  end;

  //------------------------------------------------------------------------------
  {
  const

    dam_melee : byte = 1 ;
    dam_ranged : byte = 2 ;
    dam_magic : byte = 3 ;
    wordsz = sizeof(word);

  var
    inmana : byte = 5 ;
    definshots : byte = 2 ;
    Defshotact : byte = 2 ;
    Defshotrange : byte = 3 ;
  }

function Game: TGame;
procedure CreateGame(aAppPath: string);
procedure DestroyGame();

implementation

//uses Types;

var
  fGame: TGame;

function Game: TGame;
begin
  result := fGame;
end;

procedure CreateGame(aAppPath: string);
begin
  fGame := TGame.Create(aAppPath);
end;

procedure DestroyGame();
begin
  FreeAndNil(fGame);
end;

procedure GameTimerProc(TimerID, Msg: Uint; dwUser, dw1, dw2: DWORD); stdcall;
begin
  fGame.TimerInvoke(nil);
end;

//------------------------------------------------------------------------------

{procedure TMask.SetGridMask(ay, ax, aMask : byte);
//var i,j : byte;
begin
for i := 0 to FieldHeight-1
  do for j := 0 to FieldWidth-1
    do if aMask = 0
      then Field[i,j].Mask := 0
      else if (i = ay ) and (j = ax)
        then Field[i,j].Mask := aMask
        else Field[i,j].Mask := 0;
end; }

//------------------------------------------------------------------------------

//------------------------------------------------------------------------------

//------------------------------------------------------------------------------

procedure TWarrior.Initunit;
begin
  {if not ismelee
    then ismelee := force <> franged ;
  isflyer := force = fflyer ;
  isblockfree := force = fcaval ;
  if not iscaster
    then iscaster := ishero ;
  if not isranged
    then isranged := force = franged ;
  if force = ftank
    then damage := 2
    else damage := 1 ;                  }
  life := inlife;
  inacts := 1;
  acts := inacts;
  shots := inshots;
end;

destructor TWarrior.Destroy;
begin
  inherited Destroy;
end;

procedure TWarrior.startturn;
begin
  {Moves := inMoves ;
  if isranged and (shots < inshots)
      then inc(shots);
  if iscaster and (mana < inmana)
    then inc(mana);
  acts := inacts ; }
end;

//------------------------------------------------------------------------------

function TWarrior.wound(adamage, adam_type: byte): boolean;
begin
  case adam_type of
    { dam_melee }1: result := true;
    { dam_ranged }2: result := true; //abil <> 5 ;
    { dam_magic }3: result := not isimmune;
  else
    result := false;
  end;
  if result then
  begin
    isdead := life <= adamage;
    if isdead then
      life := 0
    else
      dec(life, adamage);
  end;
  {if isdead and (fightingWarrior <> nil )
    then begin
    fightingWarrior.fightingWarrior := nil ;
    fightingWarrior.isblocked := false;
    fightingWarrior := nil ;
    end; }
end;

//------------------------------------------------------------------------------

{ TField }

procedure TField.SetCurCell(const Value: TFieldCell);
begin
  if FCurCell = Value then
    Exit;
  FCurCell := Value;
  if Assigned(FCellChanged) then
    FCellChanged(self);
end;

procedure TField.GetnearCells(yc, xc, range: byte; var sy, sx, fy, fx:
  shortint);
var
  i: byte;
begin
  sy := yc;
  fy := yc;
  sx := xc;
  fx := xc;
  for i := 1 to range do
  begin
    if sy > 0 then
      dec(sy);
    if fy < Height - 1 then
      inc(fy);
    if sx > 0 then
      dec(sx);
    if fx < Width - 1 then
      inc(fx);
  end;
end;

procedure TField.Clearplr(aplr: byte);
//var i, j : byte;
begin
  {for i := 0 to FieldHeight-1
    do for j := 0 to FieldWidth-1
      do begin
      if (Field[i,j].Warr <> nil) and (Field[i,j].Warr.plr = aplr)
        then Field[i,j].Warr := nil;
      if (Field[i,j].deadWarr <> nil) and (Field[i,j].deadWarr.plr = aplr)
        then Field[i,j].deadWarr := nil;
      end;
  }
end;

constructor TField.Create(aGame: tGame);
begin
  inherited Create(aGame.GamePix.IntfPartsColl);
  fGame := aGame;
  ImgObj := TGameImgMap.Create(aGame.GamePix.ImgObjColl);
  ImgObj.Ownr := Self;
end;

destructor TField.Destroy;
begin
  Clearmap;
  inherited;
end;

//------------------------------------------------------------------------------

procedure TField.SetField(aHeight, aWidth: TCellint);
begin
  Clearmap;
  Setlength(fField, aHeight, aWidth);
  Height := aHeight;
  Width := aWidth;
end;

Function TField.Add(ay, ax: TCellInt) : TFieldCell ;
begin
  Result := TFieldCell.Create(ay, ax, Self);
  fField[ay, ax] := Result;
end;

procedure TField.Clearmap;
var
  i, j: word;
begin
  fGame.MapLoaded := true;
  i := 0;
  while Height > i do
  begin
    j := 0;
    while Width > j do
    begin
      FreeAndNil(fField[i, j]);
      Inc(j);
    end;
    Inc(i);
  end;
  fGame.MapLoaded := false;
end;

//------------------------------------------------------------------------------

procedure TField.restore;
var
  i, j: byte;
begin
  for i := 0 to Height - 1 do
    for j := 0 to Width - 1 do
    begin
      fField[i, j].Obj.otype := fField[i, j].Obj.intype;
      fField[i, j].Obj.subtype := fField[i, j].Obj.insubtype;
    end;
end;

//------------------------------------------------------------------------------

procedure TField.ClearObj;
var
  i, j: byte;
begin
  for i := 0 to Height - 1 do
    for j := 0 to Width - 1 do
    begin
      fField[i, j].Obj.otype := otUnknown;
      fField[i, j].Obj.intype := otUnknown;
      fField[i, j].Obj.subtype := 0;
      fField[i, j].Obj.insubtype := 0;
    end;
end;
//------------------------------------------------------------------------------

function TField.GetCell(ay, ax: TCellInt): TFieldCell;
begin
  Assert(CheckInMap(ay, ax), 'out of the Field');
  result := fField[ay, ax];
end;

//------------------------------------------------------------------------------

function TField.GetHeight: TCellInt;
begin
  if fGame.MapLoaded or fGame.MapLoading then
    Result := fHeight
  else
    result := 0;
end;

//------------------------------------------------------------------------------

function TField.GetWidth: TCellInt;
begin
  if fGame.MapLoaded or fGame.MapLoading then
    Result := fWidth
  else
    result := 0;
end;

procedure TField.SetCell(ay, ax: TCellInt; aCell: TFieldCell);
begin
  if assigned(Field[ay, ax]) then
    Field[ay, ax].Free;
  Field[ay, ax] := aCell;
end;

//------------------------------------------------------------------------------

procedure TField.GetCellGrafic(aBmp: TBmp; ay, ax: TCellInt);
var
  acell: TFieldCell;
begin
  aCell := Field[ay, ax];
  ResMan.GraphicN[terassoc[aCell.tertype]].ImgLst.GetBitmap(aCell.tertex, aBmp);
  flip(aBmp, aCell.mirror[0], aCell.mirror[1]);
end;

procedure TField.SetCurCoords(const Value: TPoint);
begin
  inherited; // here we check value
  try
    SetCurCell(Field[fcurcoords.y, fcurcoords.x]);
  except
  end;
end;

//==============================================================================

function TField.CheckInMap(Ay, Ax: TCellInt): Boolean;
begin
  Result := (Ax in [0..FWidth - 1]) and (ay in [0..FHeight - 1]);
end;

{ TGame }

procedure TGame.MapLoad(Mapid: word);
begin
  MapLoading := true;

  Field.SetField(MapMgr.Mapar[Mapid].Height, MapMgr.Mapar[Mapid].Width);
  MapLoaded := MapMgr.MapLoad(Self, Mapid);
  MapLoading := false;
end;

//------------------------------------------------------------------------------

procedure TGame.SetCurplr(aplr: byte);
//var i : byte;
begin
  {for i := 1 to plrcnt
    do begin
    plrar[i].isturn := (i = aplr); // calls Tplayer.startturn
    if battleround = 0
      then plrar[i].IniTArmy ;
    end;
  fCurplr := aplr ;

  if aplr = 1
    then inc (battleround);
  }
end;

//------------------------------------------------------------------------------

constructor TGame.Create(Appdir: string);
begin
  inherited Create;
  MapMgr := tMapMgr.Create;
  GridMask := TMask.Create;
  Armies := tArmies.Create(Self {, TArmy});
  fGamePix := TGamePixels.Create(Self);
  CreateResMan;
  FInput := TInput.Create;
end;

//------------------------------------------------------------------------------

destructor TGame.Destroy;
//var i : byte ;
begin
  {for i := 1 to plrcnt
    do if assigned(plrar[i])
      then FreeAndNil(plrar[i]); }
  TimerEnabled := False;
  FreeAndNil(fGamePix);
  FreeAndNil(Armies);
  FreeAndNil(GridMask);
  unInit;
  FreeAndNil(MapMgr);
  DestroyResMan;
  FreeAndNil(FInput);
  inherited Destroy;
end;

//------------------------------------------------------------------------------

procedure TGame.ResetGridMask;
begin
  GridMask.Reset(Field.ViewZone.bottom - Field.ViewZone.Top + 1,
    Field.ViewZone.Right - Field.ViewZone.Left + 1);
end;

//------------------------------------------------------------------------------

procedure TGame.unInit;
begin
  //Field.Clearmap;
  Setlength(portalar, 0, 0);
end;

//------------------------------------------------------------------------------

procedure TGame.SetCurParty(const Value: TParty);
begin
  if value.force = fplayer then
    fCurParty := Value;
end;

//------------------------------------------------------------------------------

procedure TGame.Loadportal(anObj: tGameObj);
begin
  if length(portalar) <= anObj.subtype then
  begin
    Setlength(portalar, anObj.subtype + 1);
    Setlength(portalar[anObj.subtype], 1);
  end
  else
    Setlength(portalar[anObj.subtype], length(portalar[anObj.subtype]) + 1);
  portalar[anObj.subtype, length(portalar[anObj.subtype]) - 1] := anObj;
end;

//------------------------------------------------------------------------------

function TGame.MoveParty(aParty: TParty; aCell: TFieldCell): boolean;
var
  oCell: TFieldCell;
  ResetCurParty: boolean;
begin
  oCell := aParty.Cell;
  ResetCurParty := aParty = CurParty;
  result := aParty.Moveto(aCell);
  if not result then
    exit;
  oCell.Army.PartiesChanged;
  if ResetCurParty then
    CurParty := aCell.Army.Parties.Items[aCell.Army.Parties.Count - 1];
end;

//------------------------------------------------------------------------------

procedure TGame.SetGlobTick(const Value: cardinal);
var
  i {, j}: word;
begin
  fGlobTick := Value;
  i := 0;
  while i < Armies.Count do
  begin
    Armies.Items[i].SendTick;
    if Armies.Items[i].isdeleting then
      Armies.Delete(i);
    Inc(i);
  end;
end;

//------------------------------------------------------------------------------

procedure TGame.doTick;
begin
  GlobTick := GlobTick + 1;
  if not worldChanged then
    doTick;
  if assigned(fprocRedraw) then
    fprocRedraw;
  worldChanged := false;
  ResetGridMask;
end;

//------------------------------------------------------------------------------

procedure TGame.GridMaskinc(aCells: array of TFieldCell);
var
  i: Word;

begin
{$O-}
  for I := Low(aCells) to High(aCells) do
    if (aCells[i].yCord in [Field.ViewZone.Top..Field.ViewZone.Bottom])
      and (aCells[i].xCord in [Field.ViewZone.Left..Field.ViewZone.Right]) then
    begin
      GridMask.Cells[aCells[i].yCord - Field.ViewZone.Top, aCells[i].xCord -
        Field.ViewZone.Left] := True;
      worldChanged := true;
    end;
{$O+}
end;

function TGame.AddField(ay, ax, ah, aw: word): TField;
begin
  fField := TField.Create(Self);
  Result := fField;
  Result.xCord := ax;
  Result.yCord := ay;
  Result.gipWidth := aw;
  Result.gipHeight := ah;
end;

procedure TGame.SetprocRedraw(const Value: tprocRedraw);
begin
  FprocRedraw := Value;
end;

function TGame.GetprocRedraw: tprocRedraw;
begin
  Assert(Assigned(FprocRedraw), strRedrawError);
  result := FprocRedraw;
end;

procedure TGame.Render({hDest: THandle});
var
  b: TBmp;
begin
  TimerEnabled := False;
  B := GamePix.MainBuf;
  b.Canvas.Lock;
  if b <> nil then
    UGraph.Render({hDest, }b.Canvas.Handle);
  b.Canvas.UnLock;
  TimerEnabled := True;
end;

procedure TGame.Init(acanv: TDevice; aHeight, aWidth: word);
begin
  UGraph.Init(acanv, aHeight, aWidth);
end;

procedure TGame.TimerInvoke;
begin
  if not TimerEnabled then
    exit;
  Inc(FTimerTick);
  if Assigned(FTimerEvent) then
    FTimerEvent(nil); // may be changed to game or smth
  GamePix.Tick();
  Render();
end;

//------------------------------------------------------------------------------

procedure TGame.SetTimerEnabled(const Value: Boolean);
begin
  FTimerEnabled := Value;
if Value then
  begin
//   {
    Timer := TTimer.Create(nil);
    Timer.Interval := TmrInterval;
    Timer.OnTimer := TimerInvoke;
//    }
    {if fTimer = 0 then
      fTimer := TimeSetEvent(TmrInterval, 10, @GameTimerProc, 0, TIME_PERIODIC);
    //}
  end
  else //if fTimer <> 0 then
  begin
    Timer.Free;
    {
    TimeKillEvent(fTimer); // first disable timer
    fTimer := 0;
//    }
  end;
end;

function TGame.CreateDlg(ADlg: TDlgClass; Astr: Nlngstr;
  AProc: TDlgcallbackproc): TsimpleDlg;
begin
  TimerEnabled := False;
  Result := Adlg.Create(GamePix).builddlg(ResMan.lang[Astr], AProc);
  TimerEnabled := True;
end;

procedure TGame.SetTimerEvent(const Value: TNotifyEvent);
begin
  FTimerEvent := Value;
end;

//------------------------------------------------------------------------------

 { TInput }

procedure TInput.Clear;
var
  i, j : Integer;
begin
  for i := 0 to 7 do
    for j := 0 to 255 do
    if Assigned(FKeys[i,j]) then
      FreeAndNil(FKeys[i,j]);
end;

destructor TInput.Destroy;
begin
  Clear;
  inherited;
end;

function TInput.GetKey(Shift, Key: Byte): TMyObjList;
begin
  if not Assigned(FKeys[Shift, Key]) then
    FKeys[Shift, Key] := TMyObjList.Create(True);
  Result := FKeys[Shift, Key];
end;

function TInput.GetShift(Val: Byte): TShiftState;
begin
  Result := [];
  if (Val and 1) <> 0 then
    Include(Result, ssShift);
  if (Val and 2) <> 0 then
    Include(Result, ssAlt);
  if (Val and 4) <> 0 then
    Include(Result, ssCtrl);
end;

function TInput.GetShiftByte(AShift: TShiftState): Byte;
begin
  Result := 0;
  if ssShift in AShift then
    Inc(Result, 1);
  if ssAlt in AShift then
    Inc(Result, 2);
  if ssCtrl in AShift then
    Inc(Result, 4);
end;

procedure TInput.KeyPress(Key: Word; Shift: TShiftState);
var
  i : Integer;
  Lst : TMyObjList;
  Item : TInputItem;
begin
  Lst := FKeys[GetShiftByte(Shift), Key];
  If not Assigned(Lst) then
    Exit;
  for i := 0 to Lst.Count - 1 do
  begin
    Item := (Lst.Items[i] as TInputItem);
    Item.Event(Item.Obj);
  end;
end;

procedure TInput.RegKey(Obj: TObject; Key: Word; Shift: TShiftState; Event : TNotifyEvent);
begin
  Keys[GetShiftByte(Shift), Key].Add(TInputItem.Create(Obj, Event));
end;

//------------------------------------------------------------------------------


{ TArmy }

procedure TArmy.PartiesChanged;
begin
  if Parties.Count = 0 then
  begin
    Cell.Army := nil;
    isdeleting := true;
  end;
end;

function TArmy.Coll: TArmies;
begin
  Result := Collection as TArmies;
end;
//------------------------------------------------------------------------------

destructor TArmy.Destroy;
begin
  FreeAndNil(Parties);
  inherited;
end;

{ TParty }

{constructor TParty.Create(aCollection: tCollection);
begin
inherited Create(aCollection);

end;}

destructor TParty.Destroy;
begin
  Cell := nil;
  FreeAndNil(Warriors);
  inherited;
end;

//------------------------------------------------------------------------------

function TParty.Moveto(aCell: TFieldCell): boolean;
begin
  result := false;
  if aCell = Cell then
    exit;
  with Parties.fGame do
  begin
    // rewrite by using TFieldCell.isneighbour(distance, Cellforcheck)
    result := {((abs(aCell.yCord - Cell.yCord) in [0..1]) and (abs(aCell.xCord - Cell.xCord) in [0..1]))
    and }(aCell.tertype <> ttvoid) or isTeleporting;
    if result then
    begin
      if aCell.Army = nil then
        Armies.Add(aCell);
      Parties.fGame.GridMaskinc([aCell, Cell]);
      Path := copy(Path, 1, high(Path));
      Cell.onPath := 0;
      aCell.onPath := 0;
      Cell := aCell;
      MovetoArmy(aCell.Army);
    end;
  end;
end;

//------------------------------------------------------------------------------

procedure TParty.MovetoArmy(aArmy: TArmy);
//var aParties : TParties;
begin
  with aArmy.Parties do
  begin
    {if (Count > 0) then
      if (assigned(Items[Count-1].Warriors))
        then Add;}
    SetCollection(aArmy.Parties);
    // transfer this Party to a Parties Collection on Dest Cell
    Self.Time := 0; // fInished walking action
    Self.CurStep := 0;
  end;
end;

//------------------------------------------------------------------------------

procedure TParty.Teleport;
var
  i: byte;
begin
  for i := low(i) to high(i) do
    with Cell.Obj, Parties.fGame do
      if (length(portalar[subtype]) > i) and (portalar[subtype, i].Cell = Cell)
        then
      begin
        isTeleporting := true;
        if length(portalar[subtype]) - 1 = i
          {// if it is the last portal of that type}then
          MoveParty(Self, portalar[subtype, 0].Cell) // then Teleport to first
        else
          MoveParty(Self, portalar[subtype, i + 1].Cell); // else - to next
        exit;
      end;
end;

//------------------------------------------------------------------------------

procedure TParty.Timer();
begin
  inc(Time);
  if Time = Speed then
  begin
    doact();
    //Time := 0 ;
  end;
end;

//------------------------------------------------------------------------------

procedure TParty.doact;
//var aCell : TFieldCell;
begin
  //aCell := Cell;
  if not (force = fplayer) then
    DestCell := Cell.neighbour[random(8)];
  if (DestCell <> nil) then
    if (Path <> nil) and (CurStep <> High(Path)) then
    begin
      Inc(CurStep);
      Parties.fGame.MoveParty(Self, Parties.fGame.Field[Path[CurStep].y,
        Path[CurStep].x]);
    end
    else
      Parties.fGame.MoveParty(Self, DestCell);
end;

function TParty.GeTParties: TParties;
begin
  result := Collection as TParties;
end;

//------------------------------------------------------------------------------

procedure TParty.Init(aCell: TFieldCell);
begin
  Warriors := tWarriors.Create(Self);
  Cell := aCell;
  if force = fplayer then
    Speed := 2
  else
    Speed := random(10) + 10;
end;

procedure TArmy.SendTick;
var
  i: word;
begin
  i := 0;
  while (i < Parties.Count) do
  begin
    Parties[i].Timer;
    if isdeleting then
      exit;
    Inc(i);
  end;
end;


//------------------------------------------------------------------------------


{ TGameObj }

constructor TGameObj.Create(aCell: TFieldCell; aObjtype: nObjtype; aObjsubt:
  byte);
begin
  otype := aObjtype;
  intype := aObjtype;
  subtype := aObjsubt;
  insubtype := aObjsubt;
  Cell := aCell;
end;
destructor TGameObj.Destroy;
begin
  Cell := nil;
  inherited;
end;

function TGameObj.fGame: tGame;
begin
  Result := Cell.Field.theGame;
end;

{ TFieldCell }

constructor TFieldCell.Create(ay, ax: TCellInt; aField: TField);
begin
  //inagr := ainagr;
  //agr := ainagr;
  xCord := ax;
  yCord := ay;
  fField := aField;
end;

//------------------------------------------------------------------------------

destructor TFieldCell.Destroy;
begin
  fArmy := nil;
  FreeAndNil(fObj);
  agRowner := nil;
  fGame := nil;
  inherited;
end;

//------------------------------------------------------------------------------

function TFieldCell.GetMirror(Index: Integer): boolean;
begin
  result := ((fmirror shr index) and 1) = 1;
end;

function TFieldCell.GetNeighbour(index: integer): TFieldCell;
var
  ay, ax: shortint;
begin
  Desttocoorddelta(ndiRection(index), ay, ax);
  if (yCord + ay in [0..fGame.Field.Height - 1]) and (xCord + ax in
    [0..fGame.Field.Width - 1]) then
    result := fGame.Field[yCord + ay, xCord + ax]
  else
    result := Self;
end;

procedure TFieldCell.PuTArmy(aArmy: TArmy);
begin
  fArmy := aArmy;

end;

//------------------------------------------------------------------------------

procedure TFieldCell.PutObj(aObj: tGameObj);
begin
  fObj := aObj;
  if aObj.otype = otportal then
    fGame.Loadportal(aObj);
end;

function TFieldCell.Field: TField;
begin
  result := fField;
end;

//------------------------------------------------------------------------------


{ TWarriors }

constructor TWarriors.Create(aParty: TParty
  {; aCollItemclass : tCollectionItemclass});
begin
  inherited Create(tWarrior {aCollItemclass});
  Party := aParty;
end;

//------------------------------------------------------------------------------

destructor TWarriors.Destroy;
begin
  Party := nil;
  inherited;
end;

function TWarriors.fGame: tGame;
begin
  Result := Party.Parties.fGame;
end;

{ TArmies }

function TArmies.Add(aCell: TFieldCell): TArmy;
begin
  result := TArmy(inherited Add);
  result.Cell := aCell;
  aCell.Army := result;
  aCell.Army.Parties := TParties.Create(aCell.Army);
end;

//------------------------------------------------------------------------------

constructor TArmies.Create(aGame: tGame
  {; aCollItemclass : tCollectionItemclass});
begin
  inherited Create(TArmy {aCollItemclass});
  fGame := aGame;
end;

//------------------------------------------------------------------------------

destructor TArmies.Destroy;
begin
  fGame := nil;
  inherited;
end;

//------------------------------------------------------------------------------

function TArmies.GetItem(Index: Integer): TArmy;
begin
  Result := TArmy(inherited GetItem(Index))
end;

//------------------------------------------------------------------------------

procedure TArmies.SetItem(Index: Integer; const Value: TArmy);
begin
  inherited SetItem(Index, Value)
end;

{ TParties }

function TParties.Add(): TParty;
begin
  Result := TParty(inherited Add)
end;

//------------------------------------------------------------------------------

constructor TParties.Create(aArmy: TArmy);
begin
  inherited Create(TParty);
  Army := aArmy;
end;

//------------------------------------------------------------------------------

procedure TParties.delete(index: integer);
begin
  Army.PartiesChanged;
end;

//------------------------------------------------------------------------------

destructor TParties.Destroy;
begin
  inherited;
end;

//------------------------------------------------------------------------------

function TParties.fGame: tGame;
begin
  result := Army.Coll.fGame;
end;

function TParties.GetItem(Index: Integer): TParty;
begin
  Result := TParty(inherited GetItem(Index))
end;

procedure TParties.SetItem(Index: Integer; const Value: TParty);
begin
  inherited SetItem(Index, Value)
end;

//------------------------------------------------------------------------------

{ TInputItem }

constructor TInputItem.Create(Aobj: TObject; AEvent: TNotifyEvent);
begin
  Obj := Aobj;
  Event := AEvent;
end;

end.

